home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 1 / Cream of the Crop 1.iso / CAD / LISP04.ARJ / LEXPLODE.LSP < prev    next >
Lisp/Scheme  |  1988-07-26  |  3KB  |  74 lines
  1. ;-----------------------------------------------------------------------------+
  2. ;                               LEXPLODE.LSP                                  |
  3. ;                                                                             |
  4. ;    Larry Knott                Version 1.0                  5/25/88          |
  5. ;                                                                             |
  6. ;    Explode a BLOCK, POLYLINE, or DIMENSION and copy the entities            |
  7. ;    that replace it to the layer that the original entity was on.            |
  8. ;                                                                             |
  9. ;-----------------------------------------------------------------------------+
  10.  
  11. ;-------------------------- INTERNAL ERROR HANDLER ---------------------------|
  12.  
  13. (defun lexerr (s)                     ; If an error (such as CTRL-C) occurs
  14.                                       ; while this command is active...
  15.   (if (/= s "Function cancelled")
  16.     (princ (strcat "\nError: " s))
  17.   )
  18.   (setvar "highlight" ohl)            ; restore old highlight value
  19.   (setvar "cmdecho" oce)              ; restore old cmdecho value
  20.   (setq *error* olderr)               ; restore old *error* handler
  21.   (princ)
  22. )
  23. ;------------------------------ COMMON FUNCTION ------------------------------|
  24.  
  25. (defun getval (n e) (cdr (assoc n e)))
  26.  
  27. ;--------------------------- GET ENTITY TO EXPLODE ---------------------------|
  28.  
  29. (defun getent (t1 / no_ent e0)
  30. (setq no_ent T)
  31. (while no_ent
  32.   (if (setq e0 (entsel "\nSelect block reference, polyline, dimension, or mesh: "))
  33.     (if (member (getval 0 (setq e1 (entget (car e0)))) t1)
  34.       (if (equal (getval 0 e1) "INSERT")
  35.         (if (and (equal (getval 41 e1) (getval 42 e1))
  36.                  (equal (getval 42 e1) (getval 43 e1)))
  37.           (setq no_ent nil)
  38.           (princ "\nX, Y, and Z scale factors must be equal."))
  39.         (setq no_ent nil))
  40.       (princ "\nNot a block reference, polyline, or dimension."))
  41.     (princ " No object found."))
  42. ))
  43.  
  44. ;-------------------------------- MAIN PROGRAM -------------------------------|
  45.  
  46. (defun c:lexplode (/ oce ohl e0 en e1 s0)
  47. (setq olderr *error*
  48.       *error* lexerr)
  49. (setq oce (getvar "cmdecho"))         ; save value of cmdecho
  50. (setq ohl (getvar "highlight"))       ; save value of highlight
  51. (setvar "cmdecho" 0)                  ; turn cmdecho off
  52. (setvar "highlight" 0)                ; turn highlight off
  53. (setq e0 (entlast))
  54. (setq en (entnext e0))
  55. (while (not (null en))                ; find the last entity              
  56.   (setq e0 en)
  57.   (setq en (entnext e0))
  58. )
  59. (getent '("INSERT" "DIMENSION" "POLYLINE"))
  60. (command "explode" (getval -1 e1))    ; explode the entity
  61. (setq s0 (ssadd))
  62. (while (entnext e0) (ssadd (setq e0 (entnext e0)) s0))
  63. (command "chprop" s0 ""               ; change entities to the proper layer
  64.          "c"   "bylayer"              ; regardless of their extrusion direction
  65.          "lt"  "bylayer"
  66.          "la"  (getval 8 e1) "")
  67. (princ (strcat "\nEntities exploded onto layer " (getval 8 e1) "."))
  68. (setvar "highlight" ohl)              ; restore old highlight value
  69. (setvar "cmdecho" oce)                ; restore old cmdecho value
  70. (setq *error* olderr)                 ; restore old *error* handler
  71. (prin1))
  72.  
  73. ;------------------------------------ END ------------------------------------|
  74.